home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1991: Code Warrior / bincue / Code Warrior.bin / Development Platforms (Moof!) / LISP Related / Goal-Plan-Code Editor / library / keymacros.lisp < prev    next >
Encoding:
Text File  |  1990-07-06  |  26.0 KB  |  593 lines  |  [TEXT/MSWD]
  1. ;@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
  2. ;@@@ Keymacros to add to the programmin environment.
  3. ;@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
  4.  
  5.  
  6. ; overview: selection+movement macros; funcs to pop windows; and comment boxes
  7. ;           and meta uparrow is bound to jump to previous listener cmd.
  8. ;*******************************************************************************
  9. ;*** Selection Extension Functions
  10. ;*******************************************************************************
  11. ;
  12. ; These functions were written to wrap an interface around the ccl::ed- functions
  13. ; of the same names such that if the shift key is depressed at the same time
  14. ; as the function is called, then the current selection is extended, a la the
  15. ; Macintosh interface guidelines.
  16. ;
  17. ; The functions included are:
  18. ;
  19. ;    ccl::ed-forward-char
  20. ;    ccl::ed-backward-char
  21. ;    ccl::ed-next-line
  22. ;    ccl::ed-previous-line
  23. ;
  24. ;    ccl::ed-forward-word
  25. ;    ccl::ed-backward-word
  26. ;
  27. ;    ccl::ed-forward-sexp
  28. ;    ccl::ed-backward-sexp
  29. ;
  30. ;    ccl::ed-beginning-of-line
  31. ;    ccl::ed-end-of-line
  32. ;
  33. ; In order to use them, assign the my- function in place of the ccl::ed- function
  34. ; to the relevant key.
  35.  
  36. (defobfun (my-forward-char *fred-window*) ()
  37.   (if (ldb-test (byte 1 9) (rref *current-event* event.modifiers))
  38.     (multiple-value-bind (left right)
  39.                          (selection-range)
  40.       (let* ((the-cursor-mark (window-cursor-mark))
  41.              (the-cursor-position (mark-position the-cursor-mark)))
  42.         (set-mark the-cursor-mark
  43.                   (min (1+ the-cursor-position)
  44.                        (buffer-size (window-buffer))))
  45.         (if (eql the-cursor-position left)
  46.           (set-selection-range right)
  47.           (set-selection-range left))))
  48.     (ccl::ed-forward-char))
  49.   (when (ownp 'shifted-goal-column)
  50.     (makunbound 'shifted-goal-column)))
  51.  
  52. (defobfun (my-backward-char *fred-window*) ()
  53.   (if (ldb-test (byte 1 9) (rref *current-event* event.modifiers))
  54.     (multiple-value-bind (left right)
  55.                          (selection-range)
  56.       (let* ((the-cursor-mark (window-cursor-mark))
  57.              (the-cursor-position (mark-position the-cursor-mark)))
  58.         (set-mark the-cursor-mark
  59.                   (max (1- the-cursor-position) 0))
  60.         (if (eql the-cursor-position left)
  61.           (set-selection-range right)
  62.           (set-selection-range left))))
  63.     (ccl::ed-backward-char))
  64.   (when (ownp 'shifted-goal-column)
  65.     (makunbound 'shifted-goal-column)))
  66.  
  67. (defobfun (my-previous-line *fred-window*) ()
  68.   (declare (object-variable shifted-goal-column))
  69.   (if (ldb-test (byte 1 9) (rref *current-event* event.modifiers))
  70.     (multiple-value-bind (left right)
  71.                          (selection-range)
  72.       (let* ((the-cursor-mark (window-cursor-mark))
  73.              (the-cursor-position (mark-position the-cursor-mark))
  74.              (the-goal-column (if (ownp 'shifted-goal-column)
  75.                                 shifted-goal-column
  76.                                 (have 'shifted-goal-column
  77.                                       (buffer-column the-cursor-mark)))))
  78.         (set-mark the-cursor-mark
  79.                   (min (+ (buffer-line-start the-cursor-mark the-cursor-position -1)
  80.                           the-goal-column)
  81.                        (buffer-line-end the-cursor-mark the-cursor-position -1)))
  82.         (if (eql the-cursor-position left)
  83.           (set-selection-range right)
  84.           (set-selection-range left))))
  85.     (ccl::ed-previous-line)))
  86.  
  87. (defobfun (my-next-line *fred-window*) ()
  88.   (declare (object-variable shifted-goal-column))
  89.   (if (ldb-test (byte 1 9) (rref *current-event* event.modifiers))
  90.     (multiple-value-bind (left right)
  91.                          (selection-range)
  92.       (let* ((the-cursor-mark (window-cursor-mark))
  93.              (the-cursor-position (mark-position the-cursor-mark))
  94.              (the-goal-column (if (ownp 'shifted-goal-column)
  95.                                 shifted-goal-column
  96.                                 (have 'shifted-goal-column
  97.                                       (buffer-column the-cursor-mark)))))
  98.         (set-mark the-cursor-mark
  99.                   (min (+ (buffer-line-start the-cursor-mark the-cursor-position 1)
  100.                           the-goal-column)
  101.                        (buffer-line-end the-cursor-mark the-cursor-position 1)))
  102.         (if (eql the-cursor-position left)
  103.           (set-selection-range right)
  104.           (set-selection-range left))))
  105.     (ccl::ed-next-line)))
  106.  
  107. (defobfun (my-forward-word *fred-window*) ()
  108.   (if (ldb-test (byte 1 9) (rref *current-event* event.modifiers))
  109.     (multiple-value-bind (left right)
  110.                          (selection-range)
  111.       (let* ((the-cursor-mark (window-cursor-mark))
  112.              (the-cursor-position (mark-position the-cursor-mark))
  113.              (the-goal-position
  114.               (do* ((the-buffer (window-buffer))
  115.                     (the-buffer-end (buffer-size the-buffer))
  116.                     (the-goal-position the-cursor-position))
  117.                    ((= the-goal-position the-buffer-end) the-goal-position)
  118.                 (multiple-value-bind (start end)
  119.                                      (buffer-word-bounds the-buffer the-goal-position)
  120.                   (cond ((or (= start end)
  121.                              (= end the-goal-position))
  122.                          (incf the-goal-position))
  123.                         ((and (<= start the-goal-position)
  124.                               (>= end the-goal-position)
  125.                               (= left right))
  126.                          (setf left start)
  127.                          (return end))
  128.                         (t (return end)))))))
  129.         (set-mark the-cursor-mark the-goal-position)
  130.         (if (eql the-cursor-position left)
  131.           (set-selection-range right)
  132.           (set-selection-range left))))
  133.     (ccl::ed-forward-word))
  134.   (when (ownp 'shifted-goal-column)
  135.     (makunbound 'shifted-goal-column)))
  136.  
  137. (defobfun (my-backward-word *fred-window*) ()
  138.   (if (ldb-test (byte 1 9) (rref *current-event* event.modifiers))
  139.     (multiple-value-bind (left right)
  140.                          (selection-range)
  141.       (let* ((the-cursor-mark (window-cursor-mark))
  142.              (the-cursor-position (mark-position the-cursor-mark))
  143.              (the-goal-position
  144.               (do* ((the-buffer (window-buffer))
  145.                     (the-goal-position the-cursor-position))
  146.                    ((= the-goal-position 0) the-goal-position)
  147.                 (multiple-value-bind (start end)
  148.                                      (buffer-word-bounds the-buffer the-goal-position)
  149.                   (cond ((or (= start end)
  150.                              (= start the-goal-position))
  151.                          (decf the-goal-position))
  152.                         ((and (<= start the-goal-position)
  153.                               (>= end the-goal-position)
  154.                               (= left right))
  155.                          (setf right end)
  156.                          (return start))
  157.                         (t (return start)))))))
  158.         (set-mark the-cursor-mark the-goal-position)
  159.         (if (eql the-cursor-position left)
  160.           (set-selection-range right)
  161.           (set-selection-range left))))
  162.     (ccl::ed-backward-word))
  163.   (when (ownp 'shifted-goal-column)
  164.     (makunbound 'shifted-goal-column)))
  165.  
  166. (defobfun (my-forward-sexp *fred-window*) ()
  167.   (if (ldb-test (byte 1 9) (rref *current-event* event.modifiers))
  168.     (multiple-value-bind (left right)
  169.                          (selection-range)
  170.       (let* ((the-cursor-mark (window-cursor-mark))
  171.              (the-cursor-position (mark-position the-cursor-mark))
  172.              (the-goal-position
  173.               (let* ((the-buffer (window-buffer))
  174.                      (the-buffer-end (buffer-size the-buffer))
  175.                      (the-goal-position the-cursor-position)
  176.                      (start nil)
  177.                      (end nil))
  178.                 (loop
  179.                   (if (= the-goal-position the-buffer-end)
  180.                     (return the-goal-position)
  181.                     (progn
  182.                       (setf start (buffer-current-sexp-start-pos the-buffer
  183.                                                                  the-goal-position)
  184.                             end (when start (buffer-fwd-sexp the-buffer start)))
  185.                       (cond ((or (null start)
  186.                                  (= end the-goal-position))
  187.                              (incf the-goal-position))
  188.                             ((and (<= start the-goal-position)
  189.                                   (>= end the-goal-position)
  190.                                   (= left right))
  191.                              (setf left start)
  192.                              (return end))
  193.                             (t (return end)))))))))
  194.         (set-mark the-cursor-mark the-goal-position)
  195.         (if (eql the-cursor-position left)
  196.           (set-selection-range right)
  197.           (set-selection-range left))))
  198.     (ccl::ed-forward-sexp))
  199.   (when (ownp 'shifted-goal-column)
  200.     (makunbound 'shifted-goal-column)))
  201.  
  202. (defobfun (my-backward-sexp *fred-window*) ()
  203.   (if (ldb-test (byte 1 9) (rref *current-event* event.modifiers))
  204.     (multiple-value-bind (left right)
  205.                          (selection-range)
  206.       (let* ((the-cursor-mark (window-cursor-mark))
  207.              (the-cursor-position (mark-position the-cursor-mark))
  208.              (the-goal-position
  209.               (let* ((the-buffer (window-buffer))
  210.                      (the-goal-position the-cursor-position)
  211.                      (start nil)
  212.                      (end nil))
  213.                 (loop
  214.                   (if (= the-goal-position 0)
  215.                     (return the-goal-position)
  216.                     (progn
  217.                       (setf start (buffer-current-sexp-start-pos the-buffer
  218.                                                                  the-goal-position)
  219.                             end (when start (buffer-fwd-sexp the-buffer start)))
  220.                       (cond ((or (null start)
  221.                                  (= start the-goal-position))
  222.                              (decf the-goal-position))
  223.                             ((and (<= start the-goal-position)
  224.                                   (>= end the-goal-position)
  225.                                   (= left right))
  226.                              (setf right end)
  227.                              (return start))
  228.                             (t (return start)))))))))
  229.         (set-mark the-cursor-mark the-goal-position)
  230.         (if (eql the-cursor-position left)
  231.           (set-selection-range right)
  232.           (set-selection-range left))))
  233.     (ccl::ed-backward-sexp))
  234.   (when (ownp 'shifted-goal-column)
  235.     (makunbound 'shifted-goal-column)))
  236.  
  237. (defobfun (my-end-of-line *fred-window*) ()
  238.   (declare (object-variable shifted-goal-column))
  239.   (if (ldb-test (byte 1 9) (rref *current-event* event.modifiers))
  240.     (multiple-value-bind (left right)
  241.                          (selection-range)
  242.       (let* ((the-cursor-mark (window-cursor-mark))
  243.              (the-cursor-position (mark-position the-cursor-mark)))
  244.         (set-mark the-cursor-mark (buffer-line-end the-cursor-mark))
  245.         (if (eql the-cursor-position left)
  246.           (set-selection-range right)
  247.           (set-selection-range left))))
  248.     (ccl::ed-end-of-line))
  249.   (when (ownp 'shifted-goal-column)
  250.     (makunbound 'shifted-goal-column)))
  251.   
  252. (defobfun (my-beginning-of-line *fred-window*) ()
  253.   (if (ldb-test (byte 1 9) (rref *current-event* event.modifiers))
  254.     (multiple-value-bind (left right)
  255.                          (selection-range)
  256.       (let* ((the-cursor-mark (window-cursor-mark))
  257.              (the-cursor-position (mark-position the-cursor-mark)))
  258.         (set-mark the-cursor-mark (buffer-line-start the-cursor-mark))
  259.         (if (eql the-cursor-position left)
  260.           (set-selection-range right)
  261.           (set-selection-range left))))
  262.     (ccl::ed-beginning-of-line))
  263.   (when (ownp 'shifted-goal-column)
  264.     (makunbound 'shifted-goal-column)))
  265.  
  266. (defobfun (my-end-of-buffer *fred-window*) ()
  267.   (declare (object-variable shifted-goal-column))
  268.   (if (ldb-test (byte 1 9) (rref *current-event* event.modifiers))
  269.     (multiple-value-bind (left right)
  270.                          (selection-range)
  271.       (let* ((the-cursor-mark (window-cursor-mark))
  272.              (the-cursor-position (mark-position the-cursor-mark)))
  273.         (set-mark the-cursor-mark (buffer-size (window-buffer)))
  274.         (if (eql the-cursor-position left)
  275.           (set-selection-range right)
  276.           (set-selection-range left))))
  277.     (ccl::ed-end-of-buffer))
  278.   (when (ownp 'shifted-goal-column)
  279.     (makunbound 'shifted-goal-column)))
  280.  
  281. (defobfun (my-beginning-of-buffer *fred-window*) ()
  282.   (if (ldb-test (byte 1 9) (rref *current-event* event.modifiers))
  283.     (multiple-value-bind (left right)
  284.                          (selection-range)
  285.       (let* ((the-cursor-mark (window-cursor-mark))
  286.              (the-cursor-position (mark-position the-cursor-mark)))
  287.         (set-mark the-cursor-mark 0)
  288.         (if (eql the-cursor-position left)
  289.           (set-selection-range right)
  290.           (set-selection-range left))))
  291.     (ccl::ed-beginning-of-buffer))
  292.   (when (ownp 'shifted-goal-column)
  293.     (makunbound 'shifted-goal-column)))
  294.  
  295.   
  296. ;*******************************************************************************
  297. ;*** Function Keys
  298. ;*******************************************************************************
  299. ;
  300. ; The function keys of the Apple Extended Keyboard are not supported by the
  301. ; ccl system:  the function translating keystrokes to codes for lookup in the
  302. ; relevant command table translates all function keystrokes to #\^P, ie code 16.
  303. ; In order to support them then, without rewriting this translation function
  304. ; (#'event-keystroke, for the curious.  See 9-10 of the ccl manual), assign a
  305. ; despatching function to #\^P in the comtab which looks at the raw event and
  306. ; then does its own comtab lookup in the globally defined *control-p-comtab*.
  307. ; The translation scheme sends function keys 1 through 15 to keys #\0 through
  308. ; #\15 in this *control-p-comtab*, and the esc key to key #\0.
  309. ;
  310. ; In order to use the function keys, then, merely assign the functions to be bound
  311. ; to the function key x to the key #\x in the *control-p-comtab*.
  312.  
  313. ; create the *control-p-comtab* as a global
  314. ;
  315. (defvar *control-p-comtab* (make-comtab))
  316.  
  317.  
  318. ; the despatch function
  319. ;
  320. (defun funkey-despatch (keycode)
  321.   (declare (special *current-event* *control-p-comtab*))
  322.   (case keycode
  323.         (53 (let ((res (comtab-get-key *control-p-comtab* #\0)))
  324.                (if (and (not (null res)) (functionp res))
  325.                  (funcall res)
  326.                  (ed-beep))))
  327.         (122 (let ((res (comtab-get-key *control-p-comtab* #\1)))
  328.                (if (and (not (null res)) (functionp res))
  329.                  (funcall res)
  330.                  (ed-beep))))
  331.         (120 (let ((res (comtab-get-key *control-p-comtab* #\2)))
  332.                (if (and (not (null res)) (functionp res))
  333.                  (funcall res)
  334.                  (ed-beep))))
  335.         (99 (let ((res (comtab-get-key *control-p-comtab* #\3)))
  336.                (if (and (not (null res)) (functionp res))
  337.                  (funcall res)
  338.                  (ed-beep))))
  339.         (118 (let ((res (comtab-get-key *control-p-comtab* #\4)))
  340.                (if (and (not (null res)) (functionp res))
  341.                  (funcall res)
  342.                  (ed-beep))))
  343.         (96 (let ((res (comtab-get-key *control-p-comtab* #\5)))
  344.                (if (and (not (null res)) (functionp res))
  345.                  (funcall res)
  346.                  (ed-beep))))
  347.         (97 (let ((res (comtab-get-key *control-p-comtab* #\6)))
  348.                (if (and (not (null res)) (functionp res))
  349.                  (funcall res)
  350.                  (ed-beep))))
  351.         (98 (let ((res (comtab-get-key *control-p-comtab* #\7)))
  352.                (if (and (not (null res)) (functionp res))
  353.                  (funcall res)
  354.                  (ed-beep))))
  355.         (100 (let ((res (comtab-get-key *control-p-comtab* #\8)))
  356.                (if (and (not (null res)) (functionp res))
  357.                  (funcall res)
  358.                  (ed-beep))))
  359.         (101 (let ((res (comtab-get-key *control-p-comtab* #\9)))
  360.                (if (and (not (null res)) (functionp res))
  361.                  (funcall res)
  362.                  (ed-beep))))
  363.         (109 (let ((res (comtab-get-key *control-p-comtab* #\10)))
  364.                (if (and (not (null res)) (functionp res))
  365.                  (funcall res)
  366.                  (ed-beep))))
  367.         (103 (let ((res (comtab-get-key *control-p-comtab* #\11)))
  368.                (if (and (not (null res)) (functionp res))
  369.                  (funcall res)
  370.                  (ed-beep))))
  371.         (111 (let ((res (comtab-get-key *control-p-comtab* #\12)))
  372.                (if (and (not (null res)) (functionp res))
  373.                  (funcall res)
  374.                  (ed-beep))))
  375.         (105 (let ((res (comtab-get-key *control-p-comtab* #\13)))
  376.                (if (and (not (null res)) (functionp res))
  377.                  (funcall res)
  378.                  (ed-beep))))
  379.         (107 (let ((res (comtab-get-key *control-p-comtab* #\14)))
  380.                (if (and (not (null res)) (functionp res))
  381.                  (funcall res)
  382.                  (ed-beep))))
  383.         (113 (let ((res (comtab-get-key *control-p-comtab* #\15)))
  384.                (if (and (not (null res)) (functionp res))
  385.                  (funcall res)
  386.                  (ed-beep))))
  387.         (t (ed-beep))))
  388.  
  389. ;*******************************************************************************
  390. ;*** Window Stack
  391. ;*******************************************************************************
  392. ;
  393. ; These functions implement a simple window management scheme:  editing palettes
  394. ; are stacked to the right of the screen, while still not obscuring the disks etc
  395. ; shown by the finder, allowing the multifinder to be used; and a current editing
  396. ; palette is left where it is created, in the top left corner of the screen.
  397. ; The listener is placed below the current editing palette.
  398. ;
  399.  
  400. ;;; window stacker
  401. (defobfun (push-window *fred-window*) (&optional (select-p t))
  402.   (declare (special *window-stack*))
  403.   (when (some #'(lambda (w) (ask w (not (ownp 'wptr)))) *window-stack*)
  404.     (clean-up-window-stack))
  405.   (let ((pos (position (self) *window-stack*)))
  406.     (if pos
  407.       (move-to-stack-position pos)
  408.       (progn
  409.         (setf *window-stack* (append *window-stack* (list (self))))
  410.         (move-to-stack-position (1- (length *window-stack*))))))
  411.   (window-select-event-handler)
  412.   (when (not select-p)
  413.     (ask (find-if-not #'(lambda (w) (eq w (self))) (windows))
  414.       (window-select-event-handler))))
  415.  
  416. (defobfun (move-to-stack-position *fred-window*) (pos)
  417.   (declare (special *stack-window-size* *stack-window-position* *screen-height*))
  418.   (let ((position (min pos (floor (- *screen-height* 
  419.                                      48 
  420.                                      (point-v *stack-window-size*)) 18))))
  421.     (set-window-position (make-point (point-h *stack-window-position*)
  422.                                      (+ (point-v *stack-window-position*)
  423.                                         (* 18 position))))
  424.     (set-window-size *stack-window-size*)
  425.     (values (self))))
  426.  
  427. (defun clean-up-window-stack (&optional (first 0))
  428.   (declare (special *window-stack* *stack-window-size* *stack-window-position*))
  429.   (when (some #'(lambda (w) (ask w (not (ownp 'wptr)))) *window-stack*)
  430.     (setf *window-stack* (remove-if #'(lambda (w) (ask w (not (ownp 'wptr))))
  431.                                     *window-stack*))
  432.     (setf first 0))
  433.   (let ((the-length (length *window-stack*))
  434.         (old-first (front-window)))
  435.     (do ((pos first (1+ pos)))
  436.         ((= pos the-length) 
  437.          (progn 
  438.            (ask old-first (window-select-event-handler))
  439.            (values)))
  440.       (ask (elt *window-stack* pos)
  441.         (set-window-position (make-point (point-h *stack-window-position*)
  442.                                          (+ (point-v *stack-window-position*)
  443.                                             (* 18 pos))))
  444.         (set-window-size *stack-window-size*)
  445.         (window-select-event-handler)))))
  446.  
  447. (defobfun (pull-window *fred-window*) ()
  448.   (declare (special *window-stack*))
  449.   (let ((pos (position (self) *window-stack*)))
  450.     (when pos
  451.       (setf *window-stack* (remove (self) *window-stack*))
  452.       (set-window-position *fred-window-position*)
  453.       (set-window-size *fred-window-size*)
  454.       (cond ((some #'(lambda (w) (ask w (not (ownp 'wptr)))) *window-stack*)
  455.              (clean-up-window-stack))
  456.             ((< pos (length *window-stack*))
  457.              (clean-up-window-stack pos)))
  458.       (window-select-event-handler))))
  459.  
  460. (defun flip-window-stack (&optional (dir :forwards))
  461.   (declare (special *window-stack*))
  462.   (when (some #'(lambda (w) (ask w (not (ownp 'wptr)))) *window-stack*)
  463.     (clean-up-window-stack))
  464.   (let ((current-in-stack (position (front-window) *window-stack*)))
  465.     (if current-in-stack
  466.       (ask (elt *window-stack*
  467.                 (cond ((eq dir :forwards)
  468.                        (mod (1+ current-in-stack) (length *window-stack*)))
  469.                       ((eq dir :backwards)
  470.                        (mod (1- current-in-stack) (length *window-stack*)))
  471.                       (t (error "flip-window-stack accepts only :forwards or :backwards"))))
  472.         (window-select-event-handler))
  473.       (ask (car *window-stack*) (window-select-event-handler)))))
  474.  
  475. (when (> *screen-width* 600)
  476.   (let ((width (floor (- *screen-width* 130) 2))
  477.         (height (floor (- *screen-height* 74) 3)))
  478.     (setf *fred-window-size* (make-point width (+ 4 (* 2 height))))
  479.     (setf *fred-window-position* #@(4 44))
  480.     (setf *listener-window-size* (make-point width height))
  481.     (setf *listener-window-position* (make-point 4
  482.                                                  (+ (point-v *fred-window-position*)
  483.                                                     (point-v *fred-window-size*)
  484.                                                     22)))
  485.     (setf *stack-window-size* *fred-window-size*)
  486.     (setf *stack-window-position* (make-point (+ (point-h *fred-window-position*)
  487.                                                  (point-h *fred-window-size*)
  488.                                                  10)
  489.                                               (point-v *fred-window-position*)))
  490.     (pushnew :window-stacker *features*)
  491.     (setf *window-stack* nil)))
  492.  
  493. ;*******************************************************************************
  494. ;*** Comment Graphics
  495. ;*******************************************************************************
  496. ;
  497. ; This function merely draws nice posters to surround headings in the code.
  498. ; It supports five different levels of importance by drawing the poster with
  499. ; one of five different characters: @ * + = -.
  500.  
  501. ;;; comment graphics
  502. (defobfun (comment-graphics *fred-window*) (level)
  503.   (let* ((padchar (nth (- level 1) '(#\@ #\* #\+ #\= #\-)))
  504.          (line1 (replace
  505.                  (make-string 80 :initial-element padchar)
  506.                  ";"
  507.                  :start1 0 :end1 1 :start2 0 :start2 1))
  508.          (line2 (replace
  509.                  (replace
  510.                   (make-string 5 :initial-element padchar)
  511.                   ";"
  512.                   :start1 0 :end1 1 :start2 0 :start2 1)
  513.                  " "
  514.                  :start1 4 :end1 5 :start2 0 :start2 1)))
  515.     (fresh-line (self))
  516.     (write-line line1 (self))
  517.     (write-string line2 (self))
  518.     (let ((temp (mark-position (window-cursor-mark))))
  519.       (terpri (self))
  520.       (write-line line1 (self))
  521.       (set-mark (window-cursor-mark) temp)
  522.       (values))))
  523.  
  524. ;*******************************************************************************
  525. ;*** History
  526. ;*******************************************************************************
  527. ;
  528. ; These functions implement a crude command-line history function
  529.  
  530. ;;; to-last-cmnd-line moves the cursor to the last command line in the current
  531. ;;; buffer using find-last-cmnd-line.  
  532.  
  533. (defobfun (to-nearest-cmnd-line *fred-window*) (&optional (direction :up))            ; last command line
  534.   (unless (collapse-selection t)
  535.     (let ((p (find-nearest-cmnd-line
  536.               direction
  537.               (buffer-position (window-cursor-mark)))))
  538.       (unless (null p) (set-mark (window-cursor-mark) p)))))
  539.  
  540. ;;; find-last-cmnd-line uses the function buffer-string-pos
  541. ;;; with the key :from-end set to find the latest occurrance of the
  542. ;;; string "? " immediately preceded by a #\Newline.
  543. ;;; If there is none, then it returns the empty list.
  544. ;;; If it finds one, but the occurrance is in the same line as the
  545. ;;; position from which the search is proceeding (e.g. it was called
  546. ;;; with the cursor's position as the position from which to search, but
  547. ;;; with the cursor in a command line) then it recurs with the position
  548. ;;; of the found command line as the new starting point for the search.
  549. ;;; In other words, it ignores the command line from which it was called.
  550. ;;;
  551. ;;; There are further notes inline.
  552. ;;;
  553.  
  554. (defobfun (find-nearest-cmnd-line *fred-window*) (direction pos)
  555.   (let* ((buf (window-buffer))
  556.          (p (cond ((eq direction :up)
  557.                    (buffer-string-pos buf
  558.                                       (nsubstitute #\Newline #\n "n? ") 
  559.                                       :start 0 
  560.                                       :end (- pos 3)
  561.                                       :from-end t))
  562.                   ((eq direction :down)
  563.                    (buffer-string-pos buf
  564.                                       (nsubstitute #\Newline #\n "n? ")
  565.                                       :start (+ pos 1)
  566.                                       :end t
  567.                                       :from-end nil))
  568.                   (t nil))))
  569.     (cond ((null p) '())
  570.           ((>= 2                                ;skip over blank command lines
  571.               (- (buffer-line-end buf (+ 1 p)) 
  572.                  (buffer-line-start buf (+ 1 p))))
  573.            (find-nearest-cmnd-line direction p))
  574.           (t (+ 3 p)))))
  575.  
  576. ;;; up-a-window brings the last window in the list of windows up front
  577. (defobfun (up-a-window *fred-window*) ()
  578.   (let ((windows (cdr (windows *fred-window*))))
  579.     (if windows
  580.       (ask (car (last windows)) (window-select))
  581.       (ed-beep))))
  582.  
  583. ;;; down-a-window brings the next window in the list of windows up front
  584. (defobfun (down-a-window *fred-window*) ()
  585.   (let ((windows (cdr (windows *fred-window*))))
  586.     (if windows
  587.       (ask (car windows) (window-select))
  588.       (ed-beep))))
  589.  
  590.  
  591. (provide 'keymacros)
  592.  
  593.